perm filename MPRNT.F4[NEW,LCS]11 blob
sn#362806 filedate 1978-06-20 generic text, type T, neo UTF8
C MPRNT.F4********** DRAWS MUSIC ON THE PLOTTER OR XGP **********
C *** READS DATA FROM DSK FOR VARIOUS THINGS.
C*** UNKNOWN, ENDIT, ILLEGL, TOOMCH, PLTCMD, SLUR, NAMEXT
COMMON /DL/IXRX,SAVER,NAME,EXT /FRMT/F78F(1),FA1(1),FA5(1),ASK
1 /LIMIT/LIMIT,ITEM,L,I,M /DPY/GO,TOP,BOT /FONT/JFONT
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
C ↓↓↓↓↓ V IS FOR READIN ONLY
C%%%%%%%%
COMMON /STF/RSTFAC(0/7),RSTJ2 /POSI/STFF(0/7),JJ2,POS
1 /PTR/PWDS(350)
1/PLTR/PLT,RHT,DIS,XDIS
COMMON /XRN/ RN(3000),V(3000) /ALF/INP(72),ML /SSS/SSS(200)
1 /SLR/SLURX(272)
C ORDER OF COMMON MUST! REMAIN AS IS (FOR DMP MODE READ)
DATA DIS/1.24/
C***** CALL SEGFIX
C TO ENABLE MULTIPLE USE OF UPPER SEGMENT (TVR)
CALL MPRFAI
END
C***** SOME TYPEOUT AND ACCEPT ROUTINES *******
CC SUBROUTINE WHY
CC END
SUBROUTINE UNKNWN(JA)
CALL TYPSTR('UNKNOWN CODE =')
CALL TYPINT(JA)
CALL TYPCRLF
CCC TYPE 5700,JA
CCC5700 FORMAT(' UNKNOWN CODE=',I3)
C TRAP FOR UNKNOWN CODE #S (SUCH AS 99 - FOR "NO KSIG".
END
SUBROUTINE ENDIT(A,ITMS)
COMMON /OUTF/JJ,KOUT
CCC TYPE 300,A,ITMS,KOUT
CALL TYPFLT(A)
CALL TYPSTR(' INCHES. ')
CALL TYPINT(ITMS)
CALL TYPSTR(' ITEMS. ')
CALL TYPWRD(KOUT)
CALL TYPSTR('.PLT')
CALL PLOT(0,0,99)
C THE END OF THE DATA
CCC300 FORMAT(F7.2,' INCHES',I,' ITEMS ',9X,A5,'.PLT')
C THE END OF THE DATA
END
SUBROUTINE ILLEGL(JA)
CCC TYPE 160,JA
CCC160 FORMAT(' ILLEGAL STAFF# ',I4)
CALL TYPSTR('ILLEGAL STAFF# ')
CALL TYPINT(JA)
CALL TYPCRLF
END
SUBROUTINE TOOMCH(K)
CALL TYPSTR('***** TOO MUCH DATA ***** ')
CALL TYPINT(K)
CALL TYPSTR('/3000')
CCC TYPE 4202,K
STOP
CCC4202 FORMAT(' ***** TOO MUCH DATA ',I6,'/2500')
END
CCCCCCCCCCCCCCCCCCC SUBRS. SLUR, PLTSRT, (LINES, RDRAW),PLTCMD
SUBROUTINE PLTCMD(NOSET)
COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /OUTF/JJ,KOUT
DIMENSION NMS(20),RMOV1(20),RMOV2(20)
C**** NO MORE THAN 20 FILES PER PAGE **** (COULD BE INCREASED)
COMMON /DL/RSIZ,SAVER,NAME,EXT /ALF/INP(72),ML
COMMON R2,JE,CENTR,JB,RJQ(20),JQ(20)
EQUIVALENCE (R5,RJQ(3)),(R6,RJQ(4)),(R7,RJQ(5)),(R4,RJQ(2))
1,(R3,RJQ(1)),(I2,INP(2)),(R8,RJQ(6)),(R9,RJQ(7)),(NMS(1),NM1)
C BE CAREFUL OF COMMON OVERLAPS WITH NOTWRT,ITMSUB,HOMER, ETC.
CC F78F(1)='(78F)'
CC FA5(1)='(A5) '
DATA FA1(1)/'(A1) '/,F78F(1)/'(78F)'/,EXT/'DMD'/
IF(I2.NE.'%')GO TO 1
CC IF(I2.NE.'X')GO TO 1
I2=0
C I2=% FIRST TIME THROUGH (WAS X, BEFORE 2/78)
RXC=0
RMOV1(1)='Y'
NAME=0
14 KA=0
3 KA=KA+1
IF(MLL.EQ.0)GO TO 15
K=K-2
MLL=MLL-1
IF(MLL.NE.0)GO TO 31
IF(MORE)GO TO 10
C ADD 100 TO RSPC TO READ IN NEW ALPHABETICAL SERIES OF FILES.
CC IF(MLL.EQ.0)GO TO 10
CC GO TO 31
CCC15 TYPE 2,KA
15 CALL TYPSTR('TYPE FILE NAME')
CALL TYPINT(KA)
CALL TYPSTR(' ')
CF ACCEPT 11,K,MLL,RSPC
C TYPE FIRST NAME, NUMBER FOR A SERIES, 2ND NUM FOR FIXED SPACE ".
CALL NAMEXT(K,EXT,MLL,RSPC)
CF REREAD 351,JJ,R8
MORE=-1
IF(RSPC.LT.100)GO TO 30
MORE=0
RSPC=RSPC-100.
30 IF(KA.LT.21)GO TO 155
CALL TYPSTR('****ONLY 20 FILES ACCEPTED****')
GO TO 10
155 IF(K.NE.' ')GO TO 51
IF(KA.NE.1)GO TO 10
C DEFAULT NAME IS 'TMP 1'
K='TMP'
MLL=1
51 IF(K.EQ.'99')GO TO 140
IF(KA.EQ.1)NM1=K
C 99=BACKUP
CZZ IF(JJ.NE.'EXT ')GO TO 251
C TYPE 'EXT XXX' TO READ FILES WITH EXTENSION .XXX
CZZ EXT=R8
CZZ GO TO 15
351 FORMAT(A4,A3)
251 IF(MLL.GE.99)GO TO 151
IF(MLL.EQ.0)GO TO 151
K=K+2*(MLL-1)
C THIS CHANGES GIVEN NAME TO LAST OF SERIES.
C I.E. AAAAA 5 WILL GET AAAAE FIRST AND WORK BACKWARDS.
151 IF(K.NE.'NOSET')GO TO 31
NOSET=-1
C ACTIVATES ANTI-RESET IN MPRFAI.FAI
GO TO 15
31 IF(LOOKX(K,EXT))GO TO 56
C JUMP IF FILE FOUND
CALL TYPSTR('FILE NOT FOUND')
CALL TYPCRLF
CCC TYPE 55
GO TO 15
CCC55 FORMAT(' FILE NOT FOUND'/)
11 FORMAT(A5,I,F)
56 IF(MLL.LT.99)GO TO 560
MLL=0
561 K=K+2
C TYPE 'AAAAA 99' TO FIND ALL IN 'AAAAx' SERIES AUTOMATICALLY
MLL=MLL+1
IF(LOOKX(K,EXT))GO TO 561
C KEEPS GOING BACK IF FILES ARE FOUND
K=K-2
CALL TYPSTR('READING FILES --- ')
CALL TYPWRD(NM1)
CALL TYPCHR('.',1)
CALL TYPWRD(EXT)
CALL TYPCHR('THRU ',6)
CALL TYPWRD(K)
CALL TYPCRLF
CCC TYPE 1560,NM1,EXT,K
CCC1560 FORMAT(' READING FILES--- ',A5,'.',A3,' THRU ',A5/)
560 NMS(KA)=K
IF(MLL.EQ.0)GO TO 5
R8='Y'
IF(RSPC.NE.0)R8=RSPC
GO TO 21
5 CALL TYPSTR('MOVE UP AT END? ')
CCC5 TYPE 8
ACCEPT 11,R8
IF(R8.EQ.'99')GO TO 15
IF(R8.NE.'Y')R8=0
IF(R8.EQ.0)REREAD F78F,R8
C MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
21 RMOV1(KA+1)=R8
RMOV2(KA)=R8
GO TO 3
140 KA=KA-1
GO TO 15
10 KB=KA-1
IF(I3.NE.'G')GO TO 22
RSIZ=1
GO TO 222
22 CALL TYPSTR('SIZE FACTOR? ')
CCC22 TYPE 9
ACCEPT F78F,RSIZ,R9
C SET R9 TO 1 FOR HEAVY STAFF LINES (FOR XGP MAINLY)
IF(RSIZ.EQ.99)GO TO 5
IF(RSIZ.EQ.0)RSIZ=1.
CALL TYPSTR('TYPE OUTPUT NAME - ')
CCC TYPE 550
ACCEPT 11,JJ
IF(JJ.EQ.' ')JJ='PLT'
KOUT=JJ
CCC550 FORMAT(' TYPE OUTPUT NAME - '$)
222 KA=0
1 IF(NAME.NE.0)GO TO 12
IF(KA.NE.KB)GO TO 13
I2=-1
RETURN
C THE END OF THE DATA
13 NAME=NMS(KA+1)
CALL TYPWRD(NAME)
CALL TYPCHR('.',1)
CALL TYPWRD(EXT)
CALL TYPCRLF
CCC TYPE 111,NAME,EXT
RETURN
12 KA=KA+1
NAME=0
R8=0
R2=RSIZ
R3=RSIZ
C FOR FILLER. SIZES .LT. 1.6 = EVERY SCAN LINE, .LT. 2.6 = 2, ETC.
R7=0
R5=1
R6=1
IF(RMOV2(KA).NE.'Y')R7=RMOV2(KA)
IF(RMOV1(KA).NE.0)R5=0
IF(RMOV2(KA).NE.0)GO TO 77
IF(R7.EQ.0)RETURN
77 R6=0
CCC2 FORMAT(' TYPE FILE NAME',I2,1X$)
CCC8 FORMAT(' MOVE UP AT END? ',$)
CCC9 FORMAT(' SIZE FACTOR? ',$)
CCC111 FORMAT(1XA5,'.',A3/)
END
SUBROUTINE SLUR
IMPLICIT INTEGER(A-Q,T-Z)
COMMON /ALF/INP,SLURY(72) /SSS/ SSS(200) /SLR/ SLURX(272)
REAL CENTR
COMMON /PLTR/PLT,RHT,RDIS,XDIS
COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
1 J5,J6,J7,J8,J9,J10,J11,JQ(7),R,RJ
1 /PTR/PWDS(1) /LIMIT/LIMIT,ITEM,L,I,IX /STF/RSTFAC(0/7),RSTJ2
CF DATA RZZ/2.8/
C DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8
2 J10=1
J4=0
KQ=5
TWICE=-1
C -1 FOR DISPLAY, USES ONLY 1/3 OF SEGMENTS
IF(PLT.GE.0)GO TO 21
TWICE=0
KQ=1
RWID=.2
IF(RHT.LT.2)GO TO 21
TWICE=1
RWID=.14
C IF SIZE IS GT.2 3 SLURS ARE DRAWN
IF(RHT.LT.3)GO TO 21
TWICE=2
C IF SIZE IS GE.3 4 SLURS ARE DRAWN
RWID=.1
21 RST7=RSTJ2*7.
RQQ=R5-R4
IF(R6.GT.1000)CALL RNOTE(R6)
GO TO (5,6,7),J8+4
GO TO 4
5 R=30
CC5 R=32
C AFTER DOTTED NOTE
GO TO 8
CC6 R=18
6 R=22
C BETWEEN NOTES
8 RX=-0.75
CC8 RX=-1.3
GO TO 9
7 R=7
RX=RSTJ2
9 CALL RJBX(R)
R6=R6+RX
4 RXX=RHORZ(R6)-R3
RTILT=RQQ*RST7
80 RX=SQRT(RXX*RXX+RTILT*RTILT)
IF(J8.NE.-1)GO TO 10
IF(RQQ.GT.8)RQQ=8
IF(RQQ.LT.-8)RQQ=-8
CCCC RQQ=RQQ*RSTFAC(J2)
IF(R7)RQQ=-RQQ
R3=R3-RQQ*RSTJ2
CCCC R3=R3-RQQ
C MOVES STEEP SLUR LEFT OR RIGHT IF P8=-1
10 RJ=ABS(R7)
C R7+100=LEFT HALF SLUR, +200=RIGHT HALF, +300=REVERSE DIRECTION.
IF(RJ.LT.100)RJ=-1
IF(RJ.GE.300)RJ=0
R7=AMOD(R7,100.0)
L=RDIS*RX/5
IF(L.LT.15)L=15
IF(L.GT.68)L=68
L=L*4
C L=NUMB OF SEGMENTS IN THE CURVE.
1 R=CENTR
IF(J8.GT.0)GO TO 180
C JUMP FOR BRACKETS
CALL SLOOP
IF(J4.NE.0)GO TO 83
87 CALL LINES(SLURX(J10),SLURY(J10),3)
J4=-1
83 J5=KQ
J6=J10
J7=L
IF(J4)GO TO 22
J6=L
J7=J10
J5=-1
22 DO 88 K=J6,J7,J5
88 CALL LINES(SLURX(K),SLURY(K),2)
IF(TWICE)RETURN
TWICE=TWICE-1
IF(J8.GT.0)GO TO 182
J4=-J4
R7=R7+RWID
C RWID=WIDTH OF SLUR -- SEE DATA
GO TO 1
180 RW=R+R7*RST7
TWICE=-1
KQ=1
RX=RX+R3
CC RA=(R5-R4)*RST7
IF(J9.EQ.0)GO TO 181
TWICE=2
RZ=RTILT/(RX-R3)
RXX=RX
RWID=(R3+RXX)/2.
182 IF(TWICE.EQ.1)GO TO 183
C DOES LEFT SIDE FIRST.
IF(TWICE.EQ.0)GO TO 184
C LAST IS NUMBER.
J8=2
RC=RSTJ2*13.
RX=RWID-RC
RWW=RTILT
185 RTILT=RZ*(RX-R3)
C PUT IN FUNC. HERE FOR THIS SLOPE AND FOR PART. BEAMS.
GO TO 181
183 J8=3
RX=RXX
RTILT=RWW
RXX=R3
R3=RWID+RC
RXX=RZ*(R3-RXX)
R=R+RXX
RW=RW+RXX
GO TO 185
181 SLURX(1)=R3
SLURY(1)=R
SLURX(2)=R3
SLURY(2)=RW
SLURX(3)=RX
SLURY(3)=RW+RTILT
SLURX(4)=RX
SLURY(4)=R+RTILT
L=4
IF(J8.EQ.2)L=3
IF(J8.EQ.3)J10=2
CC TWICE=-1
GO TO 87
184 J3=RWID
C PUT IN VERT. POS. WHEN SLOPE!
R4=RQQ/2.+R4+R7-1.
R6=0.875
C .875 IS SIZE OF NUM. R7=1 MAKES ITALIC FONT
R7=1.
R8=0
CALL MAKNUM(R9)
END
C 8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
SUBROUTINE NAMEXT(NAME,EXT,NUM,SPC)
COMMON /ALF/INP(72)
DIMENSION FORM2(5),FORMT(5),NUMS(30)
DATA FORMT(1)/'('/,FORM2/'A1,','A2,','A3,','A4,','A5,'/
1, FORM3/'I,F)'/
EQUIVALENCE (F1,FORMT(1)),(F2,FORMT(2)),(F3,FORMT(3)),
1 (F4,FORMT(4)),(F5,FORMT(5))
1 FORMAT(72A1)
ACCEPT 1,INP
DO 2 K=2,72
IF(INP(K).EQ.' ')GO TO 3
2 IF(INP(K).EQ.'.')GO TO 4
3 F3=FORM3
F4=' '
F5=' '
5 F2=FORM2(K-1)
REREAD FORMT,NAME,NUM,SPC
RETURN
4 FORMT(3)=FORM2(1)
C CATCHES DOT
DO 7 N=K+1,72
7 IF(INP(N).EQ.' ')GO TO 8
8 F4=FORM2(N-K-1)
F5=FORM3
F2=FORM2(K-1)
REREAD FORMT,NAME,K,EXT,NUM,SPC
END